home *** CD-ROM | disk | FTP | other *** search
/ ShareWare OnLine 2 / ShareWare OnLine Volume 2 (CMS Software)(1993).iso / prog / gametp20.zip / RSAMPLE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-11-07  |  34KB  |  1,370 lines
  1. Program RSquid;
  2. {$X+ }
  3. {$R- }
  4. {$M 38467,0,655360 }
  5.  
  6. { RSQUID ver 1.5 Copyright 1992 by Scott D. Ramsay }
  7.  
  8. { Requires Turbo Pascal 6.0 and units:
  9.            VGAKERN.TPU
  10.            MISCFUNC.TPU
  11.            KEYBOARD.TPU
  12.            IMAGING.TPU
  13.            GMORPH.TPU
  14.            BEFFECTS.TPU
  15.            OOPOBJS.TPU
  16.            DSOUND.TPU
  17.            JOYSTICK.TPU
  18.            LIMEMS.TPU
  19.            FLICS.TPU                                               }
  20. {                                                                  }
  21. { I really don't feel like commenting this program.  Hopefully     }
  22. { most of the functions and procedures are self explanatory.       }
  23. {  I know it's sloppy coding, but I've tried to use all the        }
  24. { functions and I'm not out to win an award.                       }
  25. {  The Game pretty much covers almost all aspects of game program  }
  26. {                                                                  }
  27. {  If you have any questions about the code, or help explain, send }
  28. { me e-mail at:                                                    }
  29. {        ramsays@access.digex.com                                  }
  30. {                                                                  }
  31. { Changes from 1.0:                                                }
  32. {    Uses GameTP20 units.                                          }
  33. {    ■ Allows use with joysticks                                   }
  34. {    ■ Uses Sound Blaster compatible cards. In this example the    }
  35. {       sounds are stored in EMS because of the sprites.  If you   }
  36. {       have more than 600k of free space, you can probably store  }
  37. {       it in the heap space.  Change the line in the SETUP        }
  38. {       procedure:                                                 }
  39. {         sounds[d] := new(PEMSsound,init(path+sndname[d]));       }
  40. {       to:                                                        }
  41. {         sounds[d] := new(Psound,init(path+sndname[d]));          }
  42. {    ■ Plays the actual FLS (FLI with sound) introduction          }
  43. {    ■ Shots bounce off girls. (No harm to them!)  ;>              }
  44. {    ■ Detail level 'D' shows fast mode.  No paralax scroll. No    }
  45. {       transparent maps. ( Can make it even faster )              }
  46. {       note: You can use a different GEO file for not transparent.}
  47. {         i.e. look at the walk platforms. (The look bad where the }
  48. {              black is showing.  Create a similar GEO that is a   }
  49. {              complete filled box as a walk platform              }
  50. {    ■ Uses GMP files from GEOMAKER.                               }
  51. {        see procedure loadGMP                                     }
  52. {    ■ The TCycle modifications allows for background to scroll    }
  53. {       up and down.                                               }
  54.  
  55. Uses Crt,VgaKern,MiscFunc,KeyBoard,Imaging,Gmorph,Beffects,OopObjs,Flics,Dsound,Joystick;
  56.  
  57. type
  58.   soundtype = (shoot,explode,fried,girl_hit);
  59.  
  60. const
  61.   sndname : array[soundtype] of string =
  62.             ('ghit.voc','expl.voc','fried.voc','ric1.voc');
  63.   path    = '';
  64.   gmx     = 100;
  65.   gmy     = 50;
  66.   smx     = gmx shl 4-1;
  67.   smy     = gmy shl 4-1;
  68.   joydo   : byte = 0;
  69.   speed   : boolean = true;
  70.   speedw  : boolean = false;
  71.   firew   : boolean = false;
  72.   lvlbc   : array[0..5] of byte =
  73.             (186,80,233,239,222,208);
  74.  
  75. type
  76.   data1 = record
  77.             safe,flip,
  78.             vdx,vdy,guys,
  79.             vx,vy,drx    : integer;
  80.             lvls         : array[0..2] of integer;
  81.             score        : longint;
  82.             turn,blown   : boolean;
  83.           end;
  84.   pshot= ^tshot;
  85.   tshot = object(tobjs)
  86.             ndx,ndy  : integer;
  87.             constructor init;
  88.             procedure drawitemobject;virtual;
  89.             procedure calcitemobject;virtual;
  90.             function checkhit(hx,hy:integer;var item:pobjs):boolean;virtual;
  91.           end;
  92.   pgirl = ^tgirl;
  93.   tgirl = object(tshot)
  94.             goup,godown : boolean;
  95.             constructor init;
  96.             procedure calcitemobject; virtual;
  97.             function checkhit(hx,hy:integer;var item:pobjs):boolean;virtual;
  98.             procedure drawitemobject;virtual;
  99.             procedure checkplayertouch; virtual;
  100.           end;
  101.   pclod = ^tclod;
  102.   tclod = object(tshot)
  103.             constructor init;
  104.             procedure calcitemobject; virtual;
  105.             procedure drawitemobject;virtual;
  106.           end;
  107.   pnake = ^tnake;
  108.   tnake = object(tshot)
  109.             trn : boolean;
  110.             constructor init;
  111.             procedure drawitemobject;virtual;
  112.             function checkhit(hx,hy:integer;var item:pobjs):boolean;virtual;
  113.             procedure calcitemobject;virtual;
  114.             procedure checkplayertouch;virtual;
  115.           end;
  116.   psimm = ^tsimm;
  117.   tsimm = object(tnake)
  118.             constructor init;
  119.             procedure drawitemobject;virtual;
  120.             procedure checkplayertouch;virtual;
  121.           end;
  122.   PMyCycle = ^TMyCycle;
  123.   TMyCycle = object(Tcycle)
  124.                procedure cycle_move; virtual;
  125.              end;
  126.   PMyMorph = ^TMyMorph;
  127.   TMyMorph = object(TMorph)
  128.                function geomap(x,y:integer):integer;virtual;
  129.                procedure placegeo(x,y,geonum:integer;var geos);virtual;
  130.                procedure pre_map; virtual;
  131.                procedure post_map; virtual;
  132.              end;
  133.  
  134. var
  135.   drols,girls   : array[0..48] of pointer;
  136.   nakes         : array[0..116] of pointer;
  137.   simmers       : array[0..15] of pointer;
  138.   rsmisc        : array[0..17] of pointer;
  139.   ip            : array[1..9] of boolean;
  140.   sounds        : array[soundtype] of PEMSsound;
  141.   gwmp,gpic,
  142.   nummo         : array[0..30] of pointer;
  143.   kill          : pkill;
  144.   nkbeg,nkend   : plist;
  145.   player        : data1;
  146.   map           : array[0..gmy-1,0..gmx-1] of byte;
  147.   girls_out     : integer;
  148.   blv           : shortint;
  149.   paused,warp   : boolean;
  150.   canchk        : word;
  151.   jcx,jcy,
  152.   stx,geo_count,
  153.   ovx,ovy,gx,gy : integer;
  154.   oldexit       : pointer;
  155.   dac           : RGBlist;
  156.   MyCycle       : PMyCycle;
  157.   MyMorph       : PMyMorph;
  158.  
  159. procedure pause_ptr;external; { A VSP file using BINOBJ.EXE }
  160. {$l paused.obj }
  161.  
  162. procedure cleanup;far;
  163. var
  164.   d : soundtype;
  165. begin
  166.   for d := shoot to girl_hit do
  167.     dispose(sounds[d],done);
  168.   closemode;
  169.   exitproc := oldexit;
  170. end;
  171.  
  172.  
  173. procedure drawstatus(h:integer);
  174. var
  175.   xp : integer;
  176. begin
  177.   setpageactive(1);
  178.   xp := h shl 1+h+73;
  179.   with player do
  180.     begin
  181.       if lvls[h]<22
  182.         then
  183.           begin
  184.             if lvls[h]<1
  185.               then bar(xp,156,xp+1,178,lvlbc[h shl 1])
  186.               else bar(xp,156,xp+1,177-lvls[h],lvlbc[h shl 1]);
  187.           end;
  188.       if lvls[h]>0
  189.         then bar(xp,178-lvls[h],xp+1,178,lvlbc[h shl 1+1]);
  190.     end;
  191.   setpageactive(2);
  192. end;
  193.  
  194.  
  195. procedure page1stuff;
  196. var
  197.   p : plist;
  198.   d : integer;
  199. begin
  200.   setpageactive(2);
  201.   bar(14,155,63,178,0);
  202.   p := nkbeg;
  203.   while p<>nil do
  204.     with p^.item^ do
  205.       begin
  206.         if boolean(mapcolor)
  207.           then pset(14+nx shr 4 shr 1,155+ny shr 4 shr 1,mapcolor);
  208.         p := p^.next;
  209.       end;
  210.   with player do
  211.     pset(14+vx shr 4 shr 1,155+vy shr 4 shr 1,$c0);
  212.   fastwmatte(14,155,63,178,pages[2]^,pages[1]^);
  213.   for d := 0 to 2 do
  214.     drawstatus(d);
  215. end;
  216.  
  217.  
  218. procedure update;
  219. var
  220.   p : pointer;
  221. begin
  222.   if paused
  223.     then
  224.       begin
  225.         p := @pause_ptr; setpageactive(2);
  226.         fastput(98,64,p^);
  227.       end;
  228.   fastwmatte(13,20,172+128,179-32,pages[2]^,pages[1]^);
  229.   page1stuff;
  230. end;
  231.  
  232.  
  233. procedure ifix(var a:integer;min,max:integer);
  234. begin
  235.   if a<min
  236.     then a := min
  237.     else
  238.       if a>max
  239.         then a := max;
  240. end;
  241.  
  242.  
  243. procedure drawperson;
  244. var
  245.   nx,ny : integer;
  246. begin
  247.   with player do
  248.     begin
  249.       nx := 148; ny := 85-16;
  250.       if safe>0
  251.         then
  252.           begin
  253.             dec(nx,ord(safe<30)*random(4));
  254.             dec(ny,ord(safe<75)*random(2)-ord(safe<30)*random(4));
  255.           end;
  256.       if blown
  257.         then fbitdraw(nx,ny+4,rsmisc[2+flip]^)
  258.         else
  259.           case drx of
  260.             0 : if safe>0
  261.                   then fbitdraw(nx,ny+8,rsmisc[1]^)
  262.                   else fbitdraw(nx,ny,drols[flip]^);
  263.             1 : if turn
  264.                   then fbitdraw(nx,ny,drols[flip]^)
  265.                   else fbitdraw(nx,ny,drols[32+flip]^);
  266.            -1 : if turn
  267.                   then fbitdraw(nx,ny,drols[flip]^)
  268.                   else fbitdraw(nx,ny,drols[16+flip]^);
  269.           end;
  270.     end;
  271. end;
  272.  
  273.  
  274. procedure drawitems(over:boolean);
  275. var
  276.   p : plist;
  277. begin
  278.   p := nkbeg;
  279.   while p<>nil do
  280.     begin
  281.       if (p^.item^.overshow=over)
  282.         then p^.item^.drawitemobject;
  283.       p := p^.next;
  284.     end;
  285. end;
  286.  
  287.  
  288. procedure strobe;
  289. const
  290. { This is a hack procedure.  I didn't feel like doing the calcuation for CLC }
  291.   clc : array[0..30] of byte =
  292.         (15,14,13,12,11,10,9,8,7,6,5,4,3,2,1,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15);
  293. var
  294.   d : integer;
  295. begin
  296.   setpageactive(1);
  297.   stx := (stx+5) mod 286;
  298.   line(14,14,299,14,0);
  299.   for d := 0 to 30 do
  300.     pset((stx+d) mod 286+14,14,176+clc[d]);
  301. end;
  302.  
  303.  
  304. procedure titlepage;
  305. begin
  306.   fsetcolors(zdc);
  307.   loadpcx(path+'rsqud.pcx');
  308.   fadein(200,zdc,rgb256);
  309.   leavelast := true;
  310.   fli_play(path+'rsqud.fls',8,1,false);
  311. end;
  312.  
  313.  
  314. procedure searchjoystick;
  315. begin
  316.   if not joythere
  317.     then exit;
  318.   if joy1there
  319.     then joydo := 1
  320.     else joydo := 2;
  321.   writeln;
  322.   write('Use Joystick? (Y/N)');
  323.   repeat until ch in ['Y','N'];
  324.   if ch='N'
  325.     then
  326.       begin
  327.         joydo := 0;
  328.         exit;
  329.       end;
  330.   writeln;
  331.   writeln('Move joystick ',joydo,' to bottom-right and press button 1');
  332.   repeat
  333.     setstick(joydo);
  334.   until button1[joydo];
  335.   jcx := stickx[joydo];
  336.   jcy := sticky[joydo];
  337.   writeln('Move joystick ',joydo,' to top-left position and press button 2');
  338.   repeat
  339.     setstick(joydo);
  340.   until button2[joydo];
  341.   jcx := (jcx-stickx[joydo])div 3;
  342.   jcy := (jcy-sticky[joydo])div 3;
  343.   if jcx=0                        { Avoid Divison by zero error }
  344.     then jcx := 1;
  345.   if jcy=0
  346.     then jcy := 1;
  347. end;
  348.  
  349.  
  350. procedure loadGMP(f:string);
  351. var
  352.   mapsize,
  353.   spx,spy : word;  { Geo sprite width,height }
  354.   wpx,wpy : word;  { Map Size }
  355.   fil     : file;
  356. begin
  357.   assign(fil,f);
  358.   reset(fil,1);
  359.   blockread(fil,spx,sizeof(word)); blockread(fil,spy,sizeof(word));
  360.   blockread(fil,wpx,sizeof(word)); blockread(fil,wpy,sizeof(word));
  361.   mapsize := wpx*wpy;
  362.   blockread(fil,map,mapsize);
  363.   geo_count := 0;
  364.   while not eof(fil) do  { load VSP sprites at end of file }
  365.     begin
  366.       getmem(gpic[geo_count],buffsize(spx,spy));
  367.       blockread(fil,gpic[geo_count]^,buffsize(spx,spy));
  368.       inc(geo_count);
  369.     end;
  370.   close(fil);
  371. end;
  372.  
  373.  
  374. procedure setup;
  375. var
  376.   d   : soundtype;
  377. begin
  378.   clrscr;
  379.   writeln('Scott D. Ramsay presents:');
  380.   writeln;
  381.   writeln('R-SQUID v1.5 (unfinished, always will be)');
  382.   writeln;
  383.   writeln('This is a quick-and-dirty example of various effects PC''s can do.');
  384.   writeln(' This "puppy", is going to be slow on lower-end PC''s because I''m');
  385.   writeln('pushing the computer to the limits.  Transparent tile maps and wavering');
  386.   writeln('backgrounds will slow things down. You''ll need at least 600k of');
  387.   writeln('free ram.  VGA display, and EMS memory for sound (For sound you also');
  388.   writeln('need a Sound Blaster compatible card).  A 16mhz machine or faster is');
  389.   writeln('recommended. (16mhz might be too slow for your liking)');
  390.   writeln(' Use the "D" key during play to remove details for faster play.');
  391.   writeln;
  392.   write('Press a key.');
  393.   clearbuffer;
  394.   repeat until ch<>#1;
  395.   clearbuffer;
  396.   clrscr;
  397.   writeln;
  398.   writeln('Controls :');
  399.   writeln(' Joystick       -   (If available) Move Dude');
  400.   writeln('   button 1     -   Fire shots');
  401.   writeln(' Arrows         -   Move Dude');
  402.   writeln('                    up    = jump, up elevators');
  403.   writeln('                    down  = down elevators');
  404.   writeln('                    right = take a guess');
  405.   writeln('                    left  = -(right)');
  406.   writeln(' SPACE          -   Fire shots');
  407.   writeln('   D            -   Toggle detail level, (fast/slow)');
  408.   writeln('   P            -   Pause screen');
  409.   writeln('   A            -   Add a nake');
  410.   writeln('   S            -   Add a simmer');
  411.   writeln('  -/+           -   Adjust brightness');
  412.   writeln('  ESC           -   Quit');
  413.   writeln;
  414.   write('Press a key.');
  415.   clearbuffer;
  416.   repeat until ch<>#1;
  417.   clearbuffer;
  418.   if not ScardSetup(0,0)
  419.     then writeln('Sound card not found');
  420.   searchjoystick;
  421.   openmode(3); randomize;
  422.   titlepage;
  423.   oldexit := exitproc; exitproc := @cleanup;
  424.   loadvsp(path+'drols.vsp',drols);
  425.   loadvsp(path+'girls.vsp',girls);
  426.   loadvsp(path+'nakes.vsp',nakes);
  427.   loadvsp(path+'simmers.vsp',simmers);
  428.   loadvsp(path+'rsmisc.vsp',rsmisc);
  429.   loadGMP(path+'rsquid.gmp');
  430.   loadvsp(path+'dr2.vsp',nummo);
  431.   loadcolors(path+'rsquid.pal',dac,255);
  432.   for d := shoot to girl_hit do
  433.     sounds[d] := new(PEMSsound,init(path+sndname[d]));
  434.   fadeout(50,zdc,rgb256);
  435.   setpageactive(3);
  436.   loadpcx(path+'fire.pcx');
  437.   setpageactive(1);
  438.   loadpcx(path+'dash.pcx');
  439.   fadein(60,zdc,dac);
  440. end;
  441.  
  442.  
  443. procedure addnake;
  444. var
  445.   p : plist;
  446. begin
  447.   new(p);
  448.   p^.item := new(pnake,init);
  449.   p^.item^.powner := p;
  450.   addp(nkbeg,nkend,p);
  451. end;
  452.  
  453.  
  454. procedure setparms;
  455. var
  456.   d : integer;
  457.   p : plist;
  458. begin
  459.   MyCycle := new(PMyCycle,init(34,22));
  460.   MyCycle^.cyc_x := 13; MyCycle^.cyc_y := 20;
  461.   MyCycle^.from_x:= 0; MyCycle^.from_y:= 20;
  462.   MyCycle^.cyc_height := 128; MyCycle^.cyc_width := 320;
  463.   MyMorph := new(PMyMorph,init(gmx,gmy,19,9,13,20));
  464.   warp := true; stx := 0; girls_out := 5;
  465.   kill := nil; paused := false; blv := 0;
  466.   nkbeg := nil; nkend := nil;
  467.   with player do
  468.     begin
  469.       lvls[0] := 16; lvls[1] := 10; lvls[2] := 22;
  470.       vx := 44; vy := 55; flip := 7; score := 0;
  471.       ovx := vx; ovy := vy; vdx := 0; vdy := 0; guys := 3;
  472.       drx := 0; turn := false; safe := 100; blown := false
  473.     end;
  474.   for d := 1 to 20 do
  475.     begin
  476.       new(p);
  477.       p^.item := new(pclod,init);
  478.       addp(nkbeg,nkend,p);
  479.     end;
  480.   for d := 1 to girls_out do
  481.     begin
  482.       new(p);
  483.       p^.item := new(pgirl,init);
  484.       addp(nkbeg,nkend,p);
  485.     end;
  486.   for d := 1 to 10 do
  487.     addnake;
  488. end;
  489.  
  490.  
  491. procedure printscore;
  492. var
  493.   s : string;
  494.   d : byte;
  495. begin
  496.   s := lz(player.score,8);
  497.   setpageactive(1);
  498.   for d := 0 to length(s)-1 do
  499.     fastput(d*21+130,158,nummo[ord(s[d+1])-ord('0')]^);
  500.   setpageactive(2);
  501. end;
  502.  
  503.  
  504. function elevat(vx,vy:integer):boolean;
  505. var
  506.   cx,cy : integer;
  507.   d     : byte;
  508. begin
  509.   d := 0;
  510.   cx := (vx) shr 4; cy := (vy+15) shr 4;
  511.   if map[cy,cx] in [9,10]
  512.     then d := 1;
  513.   cx := (vx+9) shr 4; cy := (vy+15) shr 4;
  514.   if map[cy,cx] in [9,10]
  515.     then inc(d);
  516.   elevat := boolean(d);
  517. end;
  518.  
  519.  
  520. function canfall(vx,vy:integer): boolean;
  521. var
  522.   cx,cy : integer;
  523.   d     : byte;
  524. begin
  525.   d := 0;
  526.   cx := (vx) shr 4; cy := (vy+16) shr 4;
  527.   canchk := map[cy,cx];
  528.   if not (map[cy,cx] in [1,3,6,8])
  529.     then d := 1;
  530.   cx := (vx+9) shr 4; cy := (vy+16) shr 4;
  531.   if not (map[cy,cx] in [1,3,6,8])
  532.     then inc(d);
  533.   canchk := (canchk shl 8) or map[cy,cx];
  534.   canfall := (d=2);
  535. end;
  536.  
  537.  
  538. function canwalk(vx,vy:integer): boolean;
  539. var
  540.   cx,cy : integer;
  541.   d     : byte;
  542. begin
  543.   d := 0;
  544.   cx := (vx) shr 4; cy := (vy+16) shr 4;
  545.   canchk := map[cy,cx];
  546.   if map[cy,cx] in [1,3,5,6,8,10]
  547.     then d := 1;
  548.   cx := (vx+9) shr 4; cy := (vy+16) shr 4;
  549.   if map[cy,cx] in [1,3,5,6,8,10]
  550.     then inc(d);
  551.   canchk := (canchk shl 8) or map[cy,cx];
  552.   canwalk := (d=2);
  553. end;
  554.  
  555.  
  556. procedure zero(var valu:integer);
  557. begin
  558.   if valu<0
  559.     then inc(valu)
  560.     else
  561.       if valu>0
  562.         then dec(valu);
  563. end;
  564.  
  565.  
  566. procedure calcitems;
  567. var
  568.   p : plist;
  569. begin
  570.   p := nkbeg;
  571.   while p<>nil do
  572.     begin
  573.       p^.item^.calcitemobject;
  574.       p := p^.next;
  575.     end;
  576. end;
  577.  
  578.  
  579. procedure addfire;
  580. var
  581.   p : plist;
  582. begin
  583.   new(p);
  584.   p^.item := new(pshot,init);
  585.   p^.item^.powner := p;
  586.   addp(nkbeg,nkend,p);
  587. end;
  588.  
  589.  
  590. procedure addsimmers;
  591. var
  592.   p : plist;
  593. begin
  594.   new(p);
  595.   p^.item := new(psimm,init);
  596.   p^.item^.powner := p;
  597.   addp(nkbeg,nkend,p);
  598. end;
  599.  
  600.  
  601. procedure finc(var i:byte;a:shortint);
  602. begin
  603.   if i+a<0
  604.     then i := 0
  605.     else
  606.       if i+a>63
  607.         then i := 63
  608.         else inc(i,a);
  609. end;
  610.  
  611.  
  612. procedure brightcheck;
  613. var
  614.   temp : RGBlist;
  615.   d    : integer;
  616. begin
  617.   if plus and (blv<20)
  618.     then
  619.       begin
  620.         inc(blv);
  621.         temp := dac;
  622.         for d := 0 to 255 do
  623.           with temp[d] do
  624.             begin
  625.               finc(red,blv);
  626.               finc(green,blv);
  627.               finc(blue,blv);
  628.             end;
  629.         fsetcolors(temp);
  630.       end;
  631.   if minus and (blv>-20)
  632.     then
  633.       begin
  634.         dec(blv);
  635.         temp := dac;
  636.         for d := 0 to 255 do
  637.           with temp[d] do
  638.             begin
  639.               finc(red,blv);
  640.               finc(green,blv);
  641.               finc(blue,blv);
  642.             end;
  643.         fsetcolors(temp);
  644.       end;
  645. end;
  646.  
  647.  
  648. procedure pause;
  649.   procedure dit;
  650.   begin
  651.     MyCycle^.docycle(3,2,2);
  652.     update; strobe;
  653.     brightcheck;
  654.   end;
  655. begin
  656.   paused := true;
  657.   if ScardHere
  658.     then Scard_pause;
  659.   repeat dit; until ch<>'P';
  660.   repeat dit; until (ch='P') and not funct;
  661.   repeat dit; until ch<>'P';
  662.   if ScardHere
  663.     then Scard_resume;
  664.   paused := false;
  665.   setpageactive(2);
  666. end;
  667.  
  668.  
  669. procedure checkotherkeys(var detwait:boolean);
  670. var
  671.   temp : RGBlist;
  672.   d    : integer;
  673. begin
  674.   if (ch='P') and not funct
  675.     then pause;
  676.   brightcheck;
  677.   if (ch='D') and not speedw
  678.     then
  679.       begin
  680.         speed := not speed;
  681.         speedw := true;
  682.       end
  683.     else
  684.       if (ch<>'D') and speedw
  685.         then speedw := false;
  686.   case ch of
  687.     'A' : addnake;
  688.     'S' : addsimmers;
  689.   end;
  690. end;
  691.  
  692.  
  693. function sgn(h:integer):integer;
  694. begin
  695.   if h<0
  696.     then sgn := -1
  697.     else
  698.       if h>0
  699.         then sgn := 1
  700.         else sgn := 0;
  701. end;
  702.  
  703.  
  704. procedure setIPkeys;
  705. const
  706.   jl : array[1..9,0..1] of shortint =
  707.        ((-1,1),(0,1),(1,1),(-1,0),(0,0),
  708.         (1,0),(-1,-1),(0,-1),(1,-1));
  709. var
  710.   d,jx,jy : integer;
  711. begin
  712.   fillchar(ip,sizeof(ip),false);
  713.   firew := false;
  714.   if space
  715.     then firew := true;
  716.   for d := 1 to 9 do
  717.     if np[d,2]
  718.       then ip[d] := true;
  719.   if boolean(joydo)
  720.     then
  721.       begin
  722.         setstick(joydo);
  723.         jx := stickx[joydo] div jcx-1;
  724.         jy := sticky[joydo] div jcy-1;
  725.         for d := 1 to 9 do
  726.           if (jx=jl[d,0]) and (jy=jl[d,1])
  727.             then ip[d] := true;
  728.         if button1[joydo]
  729.           then firew := true;
  730.       end;
  731. end;
  732.  
  733.  
  734. procedure getkey;
  735. var
  736.   up,ovx,ovy : integer;
  737.   detwait    : boolean;
  738. begin
  739.   with player do
  740.     begin
  741.       clearbuffer; up := 0; detwait := false;
  742.       repeat
  743.         setIPkeys;
  744.         checkotherkeys(detwait);
  745.         if blown
  746.           then
  747.             begin
  748.               inc(flip);
  749.               if flip=15
  750.                 then
  751.                   begin
  752.                     blown := false;
  753.                     lvls[0] := 16;
  754.                     lvls[1] := 10;
  755.                     lvls[2] := 22;
  756.                     safe := 100;
  757.                     flip := 7;
  758.                     drx := 0;
  759.                     dec(guys);
  760.                     {if guys=0 (**)
  761.                       then gameover; }
  762.                   end;
  763.               zero(vdx);
  764.             end
  765.           else
  766.             begin
  767.               case drx of
  768.                 0 : begin
  769.                       if safe>0
  770.                         then dec(safe);
  771.                       if ip[7] or ip[4] or ip[1]
  772.                         then
  773.                           begin
  774.                             drx := 1; safe := 0;
  775.                             turn := true;
  776.                           end
  777.                         else
  778.                       if ip[9] or ip[6] or ip[3]
  779.                         then
  780.                           begin
  781.                             drx := -1; safe := 0;
  782.                             turn := true;
  783.                           end;
  784.                     end;
  785.                 1 : if turn
  786.                       then
  787.                         if flip<14
  788.                           then inc(flip,2)
  789.                           else turn := false
  790.                       else
  791.                         begin
  792.                           if ip[7] or ip[4] or ip[1]
  793.                             then flip := (flip+1)mod 16;
  794.                           if ip[9] or ip[6] or ip[3]
  795.                             then
  796.                               begin
  797.                                 flip := 15; vdx := 0;
  798.                                 drx := -1; turn := true;
  799.                               end;
  800.                         end;
  801.                -1 : if turn
  802.                       then
  803.                         if flip>1
  804.                           then dec(flip,2)
  805.                           else turn := false
  806.                       else
  807.                         begin
  808.                           if ip[9] or ip[6] or ip[3]
  809.                             then flip := (flip+1)mod 16;
  810.                           if ip[7] or ip[4] or ip[1]
  811.                             then
  812.                               begin
  813.                                 flip := 0; vdx :=0;
  814.                                 drx := 1; turn := true;
  815.                               end;
  816.                         end;
  817.               end;
  818.               ovy := vy; ovx := vx;
  819.               if (ip[7] or ip[8] or ip[9]) and elevat(vx,vy)
  820.                 then
  821.                   begin
  822.                     dec(vy);
  823.                     up := -1;
  824.                     vx := (vx+8) shr 4 shl 4;
  825.                   end
  826.                 else
  827.                   if (ip[1] or ip[2] or ip[3]) and elevat(vx,vy+1)
  828.                     then
  829.                       begin
  830.                         inc(vy);
  831.                         vx := (vx+8) shr 4 shl 4;
  832.                         up := 1;
  833.                       end;
  834.               if (vx>0) and (ip[7] or ip[4] or ip[1])
  835.                 then dec(vdx,1)
  836.                 else
  837.                   if (vx<smx) and (ip[9] or ip[6] or ip[3])
  838.                     then inc(vdx,1)
  839.                     else zero(vdx);
  840.               if firew and boolean(drx) and (lvls[2]>0)
  841.                 then
  842.                   begin
  843.                     sounds[shoot]^.play;
  844.                     addfire;
  845.                     dec(lvls[2],2);
  846.                   end
  847.                 else
  848.                   if (lvls[2]<22) and (random<0.2)
  849.                     then inc(lvls[2]);
  850.             end;
  851.         ifix(vdx,-10,10);
  852.         if canfall(vx,vy)
  853.           then
  854.             begin
  855.               if elevat(vx,vy) and (up=-1)
  856.                 then
  857.                   begin
  858.                     dec(vy);
  859.                     vy := vy shr 4 shl 4;
  860.                     vdy := 0;
  861.                   end
  862.                 else
  863.                   if (up=1) or ((up=0) and ((hi(canchk)<>10) or (lo(canchk)<>10)))
  864.                     then
  865.                       begin
  866.                         inc(vdy,3);
  867.                         if vdy>15
  868.                           then vdy := 15;
  869.                       end
  870.                     else up := 0;
  871.             end
  872.           else
  873.             begin
  874.               vy := vy shr 4 shl 4;
  875.               vdy := 0; up := 0;
  876.               if not blown and (ip[7] or ip[8] or ip[9])
  877.                 then vdy := -abs(vdx);
  878.             end;
  879.         inc(vx,vdx); inc(vy,vdy);
  880.         if vx<16
  881.           then vx := ovx
  882.           else if vx>(gmx-2) shl 4
  883.                  then vx := ovx;
  884.         calcitems;
  885.         MyMorph^.drawmap(vx,vy,gpic);
  886.         update;
  887.         cleankill_list(kill,nkbeg,nkend);
  888.       until esc;
  889.     end;
  890. end;
  891.  
  892.  
  893. function checkallhit(hx,hy:integer;item:pobjs) : boolean;
  894. var
  895.   p   : plist;
  896.   did : boolean;
  897. begin
  898.   p := nkbeg; did := false;
  899.   while (p<>nil) and not did do
  900.     begin
  901.       if p^.item^.id    { shots don't affect eachother (id=0) }
  902.         then did := p^.item^.checkhit(hx,hy,item);
  903.       p := p^.next;
  904.     end;
  905.   checkallhit := did;
  906. end;
  907.  
  908.  
  909. (**) { tshot Methods }
  910.  
  911. constructor tshot.init;
  912. begin
  913.   nx := player.vx+8; ny := player.vy; explo := false;
  914.   ndy := 0; ndx := -12*player.drx; id := false;
  915.   nrx := -player.drx; mapcolor := $fb; pointage := 0;
  916.   flp := 0; timeo := 15; overshow := false;
  917. end;
  918.  
  919.  
  920. procedure tshot.drawitemobject;
  921. begin
  922.   with player do
  923.     if range(nx,ny,vx-150,vy-80,vx+140,vy+80)
  924.       then fbitdraw(153+(nx-vx),84+(ny-vy),rsmisc[17]^);
  925. end;
  926.  
  927.  
  928. procedure tshot.calcitemobject;
  929. var
  930.   p : plist;
  931. begin
  932.   if random<0.8
  933.     then
  934.       if (nrx<0) and (ndx>-15)
  935.         then dec(ndx)
  936.         else
  937.          if (nrx>0) and (ndx<15)
  938.            then inc(ndx);
  939.   inc(nx,ndx); inc(ny,ndy); dec(timeo);
  940.   if timeo=0
  941.     then add2kill_list(kill,powner)
  942.     else
  943.       if checkallhit(nx,ny,@self)
  944.         then add2kill_list(kill,powner);
  945. end;
  946.  
  947.  
  948. function tshot.checkhit(hx,hy:integer;var item:pobjs):boolean;
  949. begin
  950.   checkhit := false;
  951. end;
  952.  
  953. (**) { Tclod Methods }
  954.  
  955. constructor tclod.init;
  956. begin
  957.   mapcolor := 0; id := false;
  958.   overshow := true;
  959.   nx := random(gmx shl 4);
  960.   ny := random((gmy-6) shl 4);
  961.   repeat
  962.     ndx := random(7)-3;
  963.   until boolean(ndx);
  964.   ndy := 0;
  965. end;
  966.  
  967.  
  968. procedure tclod.drawitemobject;
  969. begin
  970.   with player do
  971.     if range(nx,ny,vx-150,vy-90,vx+130,vy+80)
  972.       then fbitdraw(153+(nx-vx),89+(ny-vy),rsmisc[0]^);
  973. end;
  974.  
  975.  
  976. procedure tclod.calcitemobject;
  977. var
  978.   p : plist;
  979. begin
  980.   inc(nx,ndx); inc(ny,ndy);
  981.   if nx<-300
  982.     then nx := gmx shl 4+300
  983.     else
  984.       if nx>gmx shl 4+300
  985.         then nx := -300;
  986. end;
  987.  
  988. (**) { Tgirl Methods }
  989.  
  990. constructor tgirl.init;
  991. begin
  992.   mapcolor := 163; id := true; goup := false;
  993.   overshow := false; flp := 0; godown := false;
  994.   with player do
  995.     repeat
  996.       nx := random(gmx shl 4);
  997.       ny := random((gmy-4) shl 4);
  998.     until canwalk(nx,ny) and not range(nx,ny,vx-150,vy-90,vx+130,vy+80);
  999.   if random<0.4
  1000.     then ndx := -4
  1001.     else ndx := 4;
  1002.   ndy := 0; nrx := ndx;
  1003. end;
  1004.  
  1005.  
  1006. function tgirl.checkhit(hx,hy:integer;var item:pobjs):boolean;
  1007. begin
  1008.   if range(hx,hy,nx,ny,nx+12,ny+24)
  1009.     then
  1010.       begin
  1011.         sounds[girl_hit]^.play;
  1012.         pshot(item)^.ndx := -pshot(item)^.ndx;
  1013.         pshot(item)^.ndy := random(15)-7;
  1014.       end;
  1015.   checkhit := false;
  1016. end;
  1017.  
  1018.  
  1019. procedure tgirl.checkplayertouch;
  1020. var
  1021.   dir : integer;
  1022. begin
  1023.   with player do
  1024.     if not boolean(safe) and not blown and range(nx+9,ny,vx-40,vy,vx+80,vy+10)
  1025.       then
  1026.         begin
  1027.           if boolean(ndx)
  1028.             then nrx := ndx;
  1029.           dir := (nx-vx);
  1030.           if dir<-10
  1031.             then ndx := 4
  1032.             else
  1033.               if dir>10
  1034.                 then ndx := -4
  1035.                 else ndx := 0;
  1036.         end
  1037.       else
  1038.         if ndx=0
  1039.           then ndx := nrx;
  1040. end;
  1041.  
  1042.  
  1043. procedure tgirl.calcitemobject;
  1044. var
  1045.   ox,oy,b : integer;
  1046. begin
  1047.   ox := nx; oy := ny;
  1048.   if canfall(nx,ny)
  1049.     then
  1050.       begin
  1051.         if ndy<16
  1052.           then inc(ndy);
  1053.       end
  1054.     else
  1055.       begin
  1056.         ndy := 0;
  1057.         ny := ny shr 4 shl 4;
  1058.       end;
  1059.   inc(nx,ndx); inc(ny,ndy);
  1060.   if (nx<16) or (nx>(gmx-2)shl 4)
  1061.     then
  1062.       begin
  1063.         nx := ox;
  1064.         ndx := -ndx;
  1065.       end;
  1066.   if not canwalk(nx,ny) and canwalk(ox,oy) and (random<0.4)
  1067.     then
  1068.       begin
  1069.         nx := ox;
  1070.         ndx := -ndx;
  1071.       end;
  1072.   if not goup and not godown
  1073.     then flp := (flp+1)mod 16;
  1074. end;
  1075.  
  1076.  
  1077. procedure tgirl.drawitemobject;
  1078. begin
  1079.   with player do
  1080.     if range(nx,ny,vx-160,vy-60,vx+140,vy+60)
  1081.       then
  1082.         if ndx<0
  1083.           then fbitdraw(153+(nx-vx),68+(ny-vy),girls[flp]^)
  1084.           else
  1085.         if ndx>0
  1086.           then fbitdraw(153+(nx-vx),68+(ny-vy),girls[flp+16]^)
  1087.           else
  1088.         if (nx<vx)
  1089.           then fbitdraw(153+(nx-vx),68+(ny-vy),girls[16]^)
  1090.           else fbitdraw(153+(nx-vx),68+(ny-vy),girls[0]^);
  1091. end;
  1092.  
  1093.  
  1094. (**) { Tnake Methods }
  1095.  
  1096. constructor tnake.init;
  1097. begin
  1098.   repeat
  1099.     nx := random(gmx shl 4);
  1100.     ny := random(gmy-3) shl 4;
  1101.   until canwalk(nx,ny); pointage := 125;
  1102.   mapcolor := 99; id := true; explo := false;
  1103.   repeat
  1104.     ndx := random(11)-5;
  1105.   until boolean(ndx);
  1106.   ndy := 0; overshow := false;
  1107.   flp := 0; trn := false;
  1108.   if ndx<0
  1109.     then nrx := -1
  1110.     else nrx := 1;
  1111. end;
  1112.  
  1113.  
  1114. function tnake.checkhit(hx,hy:integer;var item:pobjs):boolean;
  1115. begin
  1116.   if not explo and range(hx,hy,nx,ny,nx+12,ny+24)
  1117.     then
  1118.       begin
  1119.         sounds[explode]^.play;
  1120.         explo := true; flp := 0;
  1121.         if player.vx<nx
  1122.           then nrx := -1
  1123.           else nrx := 1;
  1124.         checkhit := true;
  1125.         inc(player.score,pointage);
  1126.         printscore;
  1127.       end
  1128.     else checkhit := false;
  1129. end;
  1130.  
  1131.  
  1132. procedure tnake.drawitemobject;
  1133. begin
  1134.   with player do
  1135.     if range(nx,ny,vx-150,vy-60,vx+140,vy+60)
  1136.       then
  1137.         if explo
  1138.           then
  1139.             if ndx<0
  1140.               then
  1141.                 if nrx<0
  1142.                   then fbitdraw(153+(nx-vx),72+(ny-vy),nakes[100+flp]^)
  1143.                   else fbitdraw(153+(nx-vx),72+(ny-vy),nakes[83+flp]^)
  1144.               else
  1145.                 if nrx<0
  1146.                   then fbitdraw(153+(nx-vx),72+(ny-vy),nakes[66+flp]^)
  1147.                   else fbitdraw(153+(nx-vx),72+(ny-vy),nakes[49+flp]^)
  1148.           else
  1149.             if trn
  1150.               then fbitdraw(153+(nx-vx),72+(ny-vy),nakes[flp+32]^)
  1151.               else
  1152.                 if ndx<0
  1153.                   then fbitdraw(153+(nx-vx),72+(ny-vy),nakes[flp+16]^)
  1154.                   else fbitdraw(153+(nx-vx),72+(ny-vy),nakes[flp]^);
  1155. end;
  1156.  
  1157.  
  1158. procedure tnake.checkplayertouch;
  1159. begin
  1160.   with player do
  1161.     if not boolean(safe) and not blown and range(vx+9,vy+14,nx,ny,nx+24,ny+30)
  1162.       then
  1163.         begin
  1164.           vdx := ndx; vdy := ndy;
  1165.           if nrx=drx
  1166.             then
  1167.               begin
  1168.                 drx := -drx;
  1169.                 if drx<0
  1170.                   then flip := 15
  1171.                   else flip := 0;
  1172.                 turn := true;
  1173.               end;
  1174.           if lvls[0]>0
  1175.             then dec(lvls[0],1);
  1176.           if lvls[0]=0
  1177.             then
  1178.               begin
  1179.                 blown := true;
  1180.                 sounds[fried]^.play;
  1181.                 flip := 0;
  1182.               end;
  1183.         end;
  1184. end;
  1185.  
  1186.  
  1187. procedure tnake.calcitemobject;
  1188. var
  1189.   ox,oy : integer;
  1190. begin
  1191.   ox := nx; oy := ny;
  1192.   if not explo
  1193.     then
  1194.       begin
  1195.         inc(nx,ndx);
  1196.         inc(ny,ndy);
  1197.       end;
  1198.   if nx<16
  1199.     then nx := (gmx-2) shl 4
  1200.     else
  1201.       if nx>(gmx-2)shl 4
  1202.         then nx := 16;
  1203.   if not canwalk(nx,ny)
  1204.     then
  1205.       begin
  1206.         nx := ox; ndx := -ndx;
  1207.         trn := true;
  1208.         nrx := -nrx;
  1209.         if nrx<0
  1210.           then flp := 15
  1211.           else flp := 0;
  1212.       end;
  1213.   if not explo
  1214.     then checkplayertouch;
  1215.   if explo
  1216.     then
  1217.       begin
  1218.         inc(flp);
  1219.         if flp=15
  1220.           then add2kill_list(kill,powner)
  1221.       end
  1222.     else
  1223.      if trn
  1224.        then
  1225.          if nrx>0
  1226.            then
  1227.              begin
  1228.                inc(flp);
  1229.                if flp=15
  1230.                  then trn := false;
  1231.              end
  1232.            else
  1233.              begin
  1234.                dec(flp);
  1235.                if flp=0
  1236.                  then trn := false;
  1237.              end
  1238.        else flp := (flp+1) mod 16;
  1239. end;
  1240.  
  1241. (**) { Tsimm methods }
  1242.  
  1243. constructor tsimm.init;
  1244. begin
  1245.   repeat
  1246.     nx := random(gmx shl 4);
  1247.     ny := random(gmy-3) shl 4;
  1248.   until canwalk(nx,ny); pointage := 275;
  1249.   mapcolor := 0; id := true; explo := false;
  1250.   ndx := 5;
  1251.   nrx := 1;
  1252.   if random<0.4
  1253.     then
  1254.       begin
  1255.         ndx := -5;
  1256.         nrx := -1;
  1257.       end;
  1258.   ndy := 0; overshow := false;
  1259.   flp := 0; trn := false;
  1260. end;
  1261.  
  1262.  
  1263. procedure tsimm.drawitemobject;
  1264. begin
  1265.   with player do
  1266.     if range(nx,ny,vx-150,vy-60,vx+140,vy+60)
  1267.       then
  1268.         if explo
  1269.           then
  1270.             begin
  1271.             end
  1272.           else
  1273.             if trn
  1274.               then fbitdraw(153+(nx-vx),77+(ny-vy),simmers[flp]^)
  1275.               else
  1276.                 if ndx<0
  1277.                   then fbitdraw(153+(nx-vx),77+(ny-vy),simmers[0]^)
  1278.                   else fbitdraw(153+(nx-vx),77+(ny-vy),simmers[15]^);
  1279. end;
  1280.  
  1281.  
  1282. procedure tsimm.checkplayertouch;
  1283. begin
  1284.   with player do
  1285.     if not boolean(safe) and not blown and range(vx+9,vy+14,nx,ny,nx+24,ny+30)
  1286.       then
  1287.         begin
  1288.           vdx := ndx; vdy := ndy;
  1289.           if nrx=drx
  1290.             then
  1291.               begin
  1292.                 drx := -drx;
  1293.                 if drx<0
  1294.                   then flip := 15
  1295.                   else flip := 0;
  1296.                 turn := true;
  1297.               end;
  1298.           if lvls[0]>0
  1299.             then dec(lvls[0],1);
  1300.           if lvls[0]=0
  1301.             then
  1302.               begin
  1303.                 blown := true;
  1304.                 sounds[fried]^.play;
  1305.                 flip := 0;
  1306.               end;
  1307.         end;
  1308. end;
  1309.  
  1310. (**) { TMyCycle methods }
  1311.  
  1312. procedure TMyCycle.cycle_move;
  1313. begin
  1314.   cyclex := player.vx div 6;
  1315.   cycley := (player.vy div 6) mod cyc_height;
  1316. end;
  1317.  
  1318. (**) { TMyMorph methods }
  1319.  
  1320. function TMyMorph.geomap(x,y:integer):integer;
  1321. begin
  1322.   geomap := map[y,x];
  1323. end;
  1324.  
  1325.  
  1326. procedure TMyMorph.placegeo(x,y,geonum:integer;var geos);
  1327. begin
  1328.   if geonum in [1..geo_count]
  1329.     then
  1330.       begin
  1331.         if speed
  1332.           then fbitdraw(x,y,gpic[geonum-1]^)
  1333.           else fastwput(x,y,gpic[geonum-1]^);
  1334.       end;
  1335. end;
  1336.  
  1337.  
  1338. procedure TMyMorph.pre_map;
  1339. begin
  1340.   strobe;
  1341.   setpageActive(2);
  1342.   if speed
  1343.     then
  1344.       begin
  1345.         MyCycle^.docycle(3,2,2);
  1346.         drawitems(false);
  1347.         drawperson;
  1348.       end
  1349.     else fastwmatte(13,20,172+128,179-32,pages[3]^,pages[2]^);
  1350. end;
  1351.  
  1352.  
  1353. procedure TMyMorph.post_map;
  1354. begin
  1355.   if not speed
  1356.     then
  1357.       begin
  1358.         drawitems(false);
  1359.         drawperson;
  1360.       end;
  1361.   drawitems(true);
  1362. end;
  1363.  
  1364.  
  1365. begin
  1366.   setup;
  1367.   setparms;
  1368.   printscore;
  1369.   getkey;
  1370. end.